rm(list=ls())
set.seed(1)
library(SpatialExtremes)
library(sptmaxstable)
library(sptextremes)
library(censgauss)
require(geoR)
#Reading the data
source('read-data.R')
#loading the ind.inf. function
source('indirect-inference-function-t.R')
# defining function for indirect inference
indirect.inference=function(par.ori,data.ori,coords,prob,n.sim,df)
{
set.seed(2)
#simulation from SPT-AR MODEL (with t_df errors)
alpha<-exp(par.ori[1])/(1+exp(par.ori[1]))
range<-exp(par.ori[2])
smooth<-exp(par.ori[3])
if (smooth> 2.0){ f.value=Inf}
else {
cov.mod<-"powered.exponential"
w<-rchisq(n.sim,df=df)/df
data.sim<-grf(grid = coords,nsim = n.sim, cov.model = cov.mod,
cov.pars = c(1,range),     kappa = smooth,
mean = 0, RF=TRUE,messages = FALSE)$data
tvalues<-function(i,data,w)
{
b<-data[,i]/sqrt(w[i])
return(b)
}
data.sim<-sapply(1:n.sim, FUN = tvalues, data.sim,w)
data.sim<-sqrt((1-alpha^2))*qnorm(pt(data.sim,df))
data.sim<-apply(data.sim,1,filter, filter=alpha,method="recursive",sides=1,init=0)
#initial values for par.gauss
corrmodel<-9 # stable-stable separable model
# phi_1, phi_2 (per range) alpha, beta, gamma (smooth)
phi2.ini <- -1/log(alpha)
init.phi<-c(range  ,  phi2.ini  ,  smooth ,   1)
mask.phi<-c(TRUE,FALSE,FALSE,FALSE)
# anisotropic parameters
alpha.ani<-0
lambda.ani<-1
init.aniso<-c(alpha.ani,lambda.ani)
mask.aniso<-c(FALSE,FALSE)
# omega (velocity) in the notation of  Huser and Davison (2014)
init.velocity<-c(0, 0)
mask.velocity<-c(FALSE,FALSE)
ncores<-10 # set the number of cores.
delta.t<-2 # C_T
delta.s<-quantile(dist(coords),1) # C_S=max-dist
#subsample for initial values
n.subsample=4000
subsample=data.sim[1:n.subsample,]
#Threshold on N(0,1) scale
threshold<-qnorm(prob)
fitcp.ini<-spt.censgauss.fit(ydata=subsample,
coords = coords,  init.phi=init.phi, init.aniso=init.aniso, init.velocity=init.velocity,
delta.s= delta.s ,delta.t=delta.t, threshold = threshold,
mask.phi=mask.phi, mask.aniso=mask.aniso, mask.velocity=mask.velocity,
ncores = ncores, corrmodel = corrmodel, maxit.NM=1000)
par.gauss.ini=c(fitcp.ini$thetahat[1],phi2.ini,smooth,1)
#estimation of gaussian copula using initial values
mask.phi<-c(TRUE,TRUE,TRUE,FALSE)
delta.t<-4 # C_T
fitcp<-spt.censgauss.fit(ydata=data.sim,
coords = coords,  init.phi=par.gauss.ini, init.aniso=init.aniso, init.velocity=init.velocity,
delta.s= delta.s ,delta.t=delta.t, threshold = threshold,
mask.phi=mask.phi, mask.aniso=mask.aniso, mask.velocity=mask.velocity,
ncores = ncores, corrmodel = corrmodel,maxit.NM=2000)
par.gauss=fitcp$thetahat
par.compl.gaus=fitcp$param
if (is.null(par.gauss) | is.nan(par.gauss) | is.null(fitcp$negplik) | is.nan(fitcp$negplik)) {
f.value=Inf}
else {
# calculating auxiliary -log-likelihood on original (transformed) data
mask <- c(mask.aniso, mask.velocity, mask.phi)
nsites<-ncol(data.ori)
ntimes<-nrow(data.ori)
xy<-rep(1,ntimes)%x%as.matrix(coords)
xcoords<-xy[,1]
ycoords<-xy[,2]
tcoords<-(1:ntimes)%x%rep(1,nsites)
ydata<-t(data.ori)
y<-as.numeric(ydata)
delta<-c(delta.s,delta.t)
f.value=PLneg.spt.censgauss(par.gauss,y=y, threshold=threshold,
xcoords=xcoords, ycoords=ycoords, tcoords=tcoords,
delta=delta, param=par.compl.gaus, mask=mask, ncores=ncores,nsites=nsites,
ntimes=ntimes, corrmodel=corrmodel)
}
}
if (is.nan(f.value) | is.null(f.value) | is.infinite(f.value)) {f.value=Inf}
print(paste("fn",f.value))
f.value
}
# transform data to normal scale with empirical d.f.
rankdata<-apply(alldata,2,rank,ties.method="random")
n.ori=nrow(alldata)
data.ori=qnorm(rankdata/(n.ori+1))
prob<-0.90 # treshold level (p)
n.sim=40000 #number of simulations at each ind.inf. step (M)
degrees=2 #degrees of freedom of t distribution
#initial values for par.ori=(alpha,range, smooth)
#par.ori[1]=alpha, par.ori[2]=range (psi_1), par.ori[3]=smooth (psi_2)
#REPARAMETRIZATION:
#par[1]=log(alpha/(1-alpha))
#par[2]=log(range)
#par[3]=log(smooth)
par.ini=NULL
par.ini[1]=-0.5972073
par.ini[2]=8.6828725
par.ini[3]=-0.9788605
# optimizing with respect to par.ini=theta
fit.indirect<-optim(par=par.ini, fn=indirect.inference, data.ori=data.ori,
coords=coords,prob=prob,n.sim=n.sim,df=degrees,
method="Nelder-Mead",control=list(maxit=800))
#saving estimates
save(fit.indirect,file="NLRR-t.out")
q()
